home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / symbol-table.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  11KB  |  314 lines
  1. ;;; (C) Copyright 1990,1991 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun new-symbol-table ()
  4.   (make-array 50 :fill-pointer 0 :adjustable t))
  5.  
  6. (defun new-structure-table ()
  7.   (make-hash-table :size 200 :test #'eq))
  8.  
  9. (defun clear-symbol-table (symbol-table)
  10.   (dotimes (i (length symbol-table))
  11.     (clrhash (application-package-symbols (aref symbol-table i))))
  12.   (setf (fill-pointer symbol-table) 0)
  13.   symbol-table)
  14.  
  15. #+NATIVE-WCL
  16. (defun translate-host-package (package)
  17.   package)
  18.  
  19. #-NATIVE-WCL
  20. (defun translate-host-package (package)
  21.   (if (or (eq package *wcl-package*)
  22.       (eq package *lcl-package*))    ; Lucid specific
  23.       *host-lisp-package*
  24.       package))
  25.  
  26. (defun find-application-package (package symbol-table)
  27.   (dotimes (i (length symbol-table))
  28.     (let ((entry (aref symbol-table i)))
  29.       (when (eq (application-package-host-package entry)
  30.         (translate-host-package package))
  31.     (return entry)))))
  32.  
  33. (defun find-or-make-application-package (package symbol-table)
  34.   (or (find-application-package package symbol-table)
  35.       (let* ((host-package (translate-host-package package))
  36.          (new (make-application-package
  37.            :host-package host-package
  38.            :symbol-array-c-name
  39.            (lisp->c-name "package_symbols_"
  40.                  (package-name host-package)
  41.                  0)
  42.            :symbols (make-hash-table :size 6000 :test #'eq))))
  43.     (vector-push-extend new symbol-table)
  44.     new)))
  45.  
  46. (defun find-application-symbol-in-symbol-table (symbol symbol-table)
  47.   (let ((app-package (find-application-package (symbol-package symbol)
  48.                            symbol-table)))
  49.     (if (null app-package)
  50.     nil
  51.     (multiple-value-bind (app-symbol found?)
  52.         (gethash symbol (application-package-symbols app-package))
  53.       (if found? app-symbol nil)))))
  54.  
  55. (defun find-application-symbol-in-libraries (symbol libraries)
  56.   (dolist (lib libraries)
  57.     (let ((app-symbol (find-application-symbol-in-symbol-table
  58.                symbol (library-symbol-table lib))))
  59.       (unless (null app-symbol)
  60.     (return app-symbol)))))
  61.  
  62. (defun find-application-symbol (symbol libraries symbol-table)
  63.   (or (find-application-symbol-in-libraries symbol libraries)
  64.       (find-application-symbol-in-symbol-table symbol symbol-table)))
  65.  
  66. (defun intern-application-symbol (symbol libraries symbol-table)
  67.   (let ((app-sym (find-application-symbol symbol libraries symbol-table)))
  68.     (if (null app-sym)
  69.     (make-new-application-symbol-in-symbol-table symbol symbol-table)
  70.     app-sym)))
  71.  
  72. (defun intern-application-symbol-in-symbol-table (symbol symbol-table)
  73.   (or (find-application-symbol-in-symbol-table symbol symbol-table)
  74.       (make-new-application-symbol-in-symbol-table symbol symbol-table)))
  75.  
  76. (defun make-new-application-symbol-in-symbol-table (symbol symbol-table)
  77.   (let* ((package (symbol-package symbol))
  78.      (app-symbol (make-application-symbol
  79.               :sym symbol
  80.               :value (if (eq package *keyword-package*)
  81.                  symbol
  82.                  *unbound*)))
  83.      (app-pkg (find-or-make-application-package package symbol-table)))
  84.     (setf (gethash symbol (application-package-symbols app-pkg))
  85.       app-symbol)))
  86.  
  87. (defun intern-application-symbol-used-as-data (symbol libraries symbol-table)
  88.   (let ((s (intern-application-symbol symbol libraries symbol-table)))
  89.     (setf (application-symbol-used-as-data? s) t)
  90.     s))
  91.  
  92. (defun set-application-symbol-flag (s flag-position)
  93.   (setf (application-symbol-flags s)
  94.     (logior (application-symbol-flags s) (ash 1 flag-position))))
  95.  
  96. (defun set-application-symbol-value (app-sym vlabel flag)
  97.   (unless (eq (application-symbol-value app-sym) *unbound*)
  98.     (warn "Multiple symbol values for ~A" (application-symbol-sym app-sym)))
  99.   (set-application-symbol-flag app-sym flag)
  100.   (setf (application-symbol-value app-sym) vlabel))
  101.  
  102. (defun set-application-symbol-function (app-sym flabel)
  103.   (unless (null (application-symbol-function app-sym))
  104.     (warn "Multiple symbol functions for ~A" (application-symbol-sym app-sym)))
  105.   (setf (application-symbol-function app-sym) flabel))
  106.  
  107. (defun setup-application-symbols (libraries symbol-table structures winfiles
  108.                         &optional library)
  109.   (loop
  110.    with inits = nil
  111.    with symbol-fixups = nil
  112.    for winfile in winfiles do
  113.    (with-open-file (input (merge-pathnames ".c" winfile))
  114.      (let ((*package* *package*))
  115.        (read-line input)        ; discard "/*"
  116.        (loop
  117.     for cmd = (read input nil input)
  118.     until (eq cmd :end)
  119.     do
  120.     (let ((symbol (read input)))
  121.       (case cmd
  122.         (:init (push symbol inits))
  123.         (:sym (intern-application-symbol-used-as-data
  124.            symbol libraries symbol-table))
  125.         (:comment nil)
  126.         (:version nil)        ; HEY! check it
  127.         (:proclaim (unless (null library)
  128.              (push symbol (library-proclaims library))))
  129.         (:pinfo
  130.          (if (null library)
  131.          (read-line input)
  132.          (let* ((table (library-procedure-info library))
  133.             (info (or (gethash symbol table)
  134.                   (setf (gethash symbol table)
  135.                     (make-proc-info :name symbol)))))
  136.            (read-procedure-info-line info input))))
  137.         (:finfo
  138.          (if (null library)
  139.          (read-line input)
  140.          (let* ((table (library-procedure-info library))
  141.             (info (or (gethash symbol table)
  142.                   (setf (gethash symbol table)
  143.                     (make-foreign-info :name symbol)))))
  144.            (read-foreign-info-line info input))))
  145.         (:end-package-info nil)
  146.         (:package (eval symbol))    ; symbol is really a pkg cmd
  147.         (:c-type (let ((type (read input)))
  148.                (unless (null library)
  149.              (setf (gethash symbol (library-c-type-info library))
  150.                    type))))
  151.         (:structure
  152.          (read-line input)        ; discard fluid-predicate-name-c-name
  153.          (add-application-structure symbol structures))
  154.         (t
  155.          (let ((argument (read input)))
  156.            (let ((existing-app-sym
  157.               (find-application-symbol-in-libraries
  158.                symbol libraries)))
  159.          (if (null existing-app-sym)
  160.              (let ((new-app-sym
  161.                 (intern-application-symbol-in-symbol-table
  162.                  symbol symbol-table)))
  163.                (case cmd
  164.              (:sv (set-application-symbol-value
  165.                    new-app-sym argument special-symbol-flag))
  166.              (:sc (set-application-symbol-value
  167.                    new-app-sym argument constant-symbol-flag))
  168.              (:sf (set-application-symbol-function
  169.                    new-app-sym argument))
  170.              (:sm (set-application-symbol-function
  171.                    new-app-sym argument)
  172.                   (set-application-symbol-flag
  173.                    new-app-sym macro-symbol-flag))))
  174.              ;; Cannot statically init other library symbols, so
  175.              ;; we must collect code to alter them at run time.
  176.              (push (symbol-init->c-code cmd symbol argument)
  177.                symbol-fixups))))))))))
  178.    finally (return (values (nreverse inits) ; preserve init order!
  179.                (nreverse symbol-fixups)))))
  180.  
  181. (defun symbol-init->c-code (cmd symbol argument)
  182.   (let ((symbol-c-name (lisp->c-symbol-name symbol))
  183.     (s (make-string-output-stream)))
  184.     (unwind-protect
  185.      (ecase cmd
  186.        ((:sv :sc)
  187.         (let* ((*k-stream* s)
  188.            (data-ref (emit-data argument))
  189.            (data-decl (get-output-stream-string s))
  190.            (flag (case cmd
  191.                (:sv special-symbol-flag)
  192.                (:sc constant-symbol-flag))))
  193.           (format nil "{extern SYMBOL ~A; ~A UPDATE_VAR(~A,~A,~D);~%"
  194.               symbol-c-name data-decl symbol-c-name data-ref flag)))
  195.        ((:sf :sm)
  196.         (let* ((label (emit-application-proc argument s))
  197.            (proc-decl (get-output-stream-string s)))
  198.           (case cmd
  199.         (:sf (format nil
  200.                  "{extern SYMBOL ~A; ~A UPDATE_FUNC(~A,~A);}"
  201.                  symbol-c-name proc-decl symbol-c-name label))
  202.         (:sm (error "Fix linker macro update"))))))
  203.       (close s))))
  204.  
  205. (defun add-application-structure (info table)
  206.   (let ((name (struct-info-name info)))
  207.     (when (gethash name table)
  208.       (warn "Multiple structure definitions for ~A" name))
  209.     (setf (gethash name table) info)
  210.     (let ((include-info (gethash (struct-info-include info) table)))
  211.       (unless (null include-info)
  212.     (pushnew (struct-info-name info)
  213.          (struct-info-children include-info))))))
  214.  
  215. (defun transitive-structure-children (info table)
  216.   (if (null (struct-info-children info))
  217.       nil
  218.       (loop for c in (struct-info-children info)
  219.         appending (cons c (transitive-structure-children (gethash c table)
  220.                                  table)))))
  221.  
  222. (defun application-structure-predicate (info table)
  223.   (let* ((name (struct-info-name info))
  224.      (children (transitive-structure-children info table)))
  225.     `(defun ,(predicate-name info) (s)
  226.       ,(if (struct-info-dynamic? info)
  227.        `(,(fluid-predicate-name info) s)
  228.        `(and (structurep s)
  229.          ,(if (null children)
  230.           `(%eq (structure-type s) ',name)
  231.           `(find-eq/simple-vector (structure-type s)
  232.             ,(coerce (cons name children) 'vector))))))))
  233.  
  234. (defun emit-application-proc (name stream)
  235.   (if (null name)
  236.       "ubf_procedure"
  237.       (let ((label (genstring "p")))
  238.     (format stream "~%extern LP ~A();~%" name)
  239.     (format stream "MAKE_PROCEDURE(~A,~A);~%" label name)
  240.     label)))
  241.  
  242. (defun emit-application-symbol (s)    
  243.   (let* ((vcell (application-symbol-value s))
  244.      (vcell-constant (cond ((eq vcell *unbound*) nil)
  245.                    ;; LABEL stuff is obsolete???
  246.                    ;; ((label-p vcell) (label-name vcell))
  247.                    (t (emit-lref vcell))))
  248.      (proc (emit-application-proc (application-symbol-function s)
  249.                       *k-stream*)))
  250.     (let* ((sym (application-symbol-sym s))
  251.        (name (emit-lref (symbol-name sym)))
  252.        (hash-code (emit-lref (sxhash-w (application-symbol-sym s)))))
  253.       (emit-k "~%MAKE_SYMBOL(~A,~A,NIL,~A,NIL,LREF(~A),~A,~D);~%"
  254.           (application-symbol-c-name s)
  255.           (if (null vcell-constant)
  256.           "((LP) UBV_MARKER)"
  257.           vcell-constant)
  258.           name
  259.           proc
  260.           hash-code
  261.           (application-symbol-flags s)))))
  262.  
  263. (defun link-application-symbol? (app-symbol)
  264.  (or *link-every-symbol?*
  265.      (application-symbol-used-as-data? app-symbol)))
  266.  
  267. (defun emit-symbol-table-symbols (symbol-table)
  268.   (loop for app-package being the array-elements of  symbol-table
  269.     do (maphash #'(lambda (sym app-sym)
  270.             (declare (ignore sym))
  271.             (when (link-application-symbol? app-sym)
  272.               (emit-application-symbol app-sym)))
  273.             (application-package-symbols app-package))))
  274.  
  275. (defun emit-symbol-table-symbol-arrays (symbol-table)
  276.   (loop for app-package being the array-elements of symbol-table
  277.     do
  278.     (progn (emit-k "~%static unsigned long ~A[] = {~%"
  279.                (application-package-symbol-array-c-name app-package))
  280.            (maphash #'(lambda (sym app-sym)
  281.                 (declare (ignore sym))
  282.                 (when (link-application-symbol? app-sym))
  283.                 (emit-k "LREF(~A),~%"
  284.                     (application-symbol-c-name app-sym)))
  285.             (application-package-symbols app-package))
  286.            (emit-k "0};~%"))))
  287.  
  288. (defun emit-symbol-table-registration-code (symbol-table)
  289.   (loop for app-package being the array-elements of symbol-table
  290.     do (let ((package (application-package-host-package app-package)))
  291.          ;; HEY! This is a hack to deal with uninterned symbols.
  292.          ;; probably need something better...
  293.          (unless (null package)
  294.            (emit-k "register_symbols(~S,~A);~%"
  295.                (package-name package)
  296.                (application-package-symbol-array-c-name
  297.             app-package))))))
  298.  
  299. (defun emit-symbol-table (libraries symbol-table)
  300.   (format *k-stream* "~%#include \"lisp.h\"~%~%")
  301.   ;; add new sym found to new table, then merge new into main table.
  302.   ;; then emit arrays.
  303.   (let ((*emit-symbol-data-function*
  304.      #'(lambda (symbol)
  305.          (unless (find-application-symbol symbol libraries symbol-table)
  306.            (break "Symbol ~S loses!" symbol)))))
  307.     (emit-symbol-table-symbols symbol-table))
  308.   (emit-symbol-table-symbol-arrays symbol-table))
  309.  
  310.   
  311.  
  312.  
  313.  
  314.